home *** CD-ROM | disk | FTP | other *** search
/ BMUG Revelations / BMUG Revelations.toast / Programming / Programming Languages / XLisp 2.1e3 / lisp / classes.lsp < prev    next >
Lisp/Scheme  |  1992-10-29  |  6KB  |  213 lines
  1. ; useful stuff for object programming
  2.  
  3. ; filter certain keyword arguments for passing argument list to superclass
  4.  
  5. (defun remove-keys (keys list)
  6.     (cond ((null keys) list)
  7.       ((null list) 'nil)
  8.       ((member (car list) keys)
  9.        (remove-keys (remove (car list) keys) (cddr list)))
  10.       (t (cons (car list) (remove-keys keys (cdr list))))))
  11.  
  12.  
  13. ; fix so that classes can be named (requires PNAME ivar in class Class)
  14. ;  The source files have been modified for PNAME instance variable,
  15. ;  and printing of class PNAME if it exists.
  16.  
  17. (send class :answer :set-pname
  18.       '(name)
  19.       '((setf pname (string name))))
  20.  
  21.  
  22. ; *setf* property of SEND is set to allow setting instance variables
  23.  
  24. (setf (get 'send '*setf*) 
  25.       #'(lambda (obj ivar value) 
  26.         (send obj :set-ivar (get ivar 'ivarname) value)))
  27.  
  28. ; (defclass <classname> [(<instvars>) [(<classvars>) [<superclass>]]])
  29. ; defclass sets up access methods for all instance and class variables!
  30. ; an instance variable can be of form <ivar>  or (<ivar> <init>)
  31. ; :ISNEW is automatically defined to accept keyword arguments to overide
  32. ; default initialization.
  33.  
  34. (defmacro defclass (name &optional ivars cvars super 
  35.              &aux (sym (gensym)) (sym2 (gensym)))
  36. ; CIVAR is instance variable list with init values removed
  37.     (let ((civars (mapcar #'(lambda (x) (if (consp x) (car x) x))
  38.               ivars)))
  39.  
  40.       `(progn ; Create class and assign to global variable
  41.               (setf ,name
  42.             (send class :new
  43.               ',civars
  44.               ',cvars
  45.               ,@(if super (list super) nil)))
  46.  
  47.           ; Set the name ivar of the class
  48.           (send ,name :set-pname ',name)
  49.  
  50.           ; Generate the :<ivar> and :<cvar> methods
  51.           ,@(mapcar #'(lambda (arg)
  52.                 `(send ,name
  53.                    :answer
  54.                    ,(intern (strcat ":" (string arg)))
  55.                    'nil
  56.                    '(,arg)))
  57.                 (append civars cvars))
  58.  
  59.           ; The method needed to set the instance variables
  60.           (send ,name :answer :set-ivar
  61.             '(,sym ,sym2)
  62.             '((case ,sym
  63.                 ,@(mapcar #'(lambda (arg)
  64.                            `(,arg (setq ,arg ,sym2)))
  65.                       (append civars cvars))
  66.                 (t (send-super :set-ivar ,sym ,sym2)))))
  67.  
  68.           ; Set the ivarname property of the :<ivar> symbols
  69.           ,@(mapcar #'(lambda (arg)
  70.                       `(setf (get ',(intern (strcat ":" (string arg)))
  71.                             'ivarname)
  72.                    ',arg))
  73.                 civars)
  74.  
  75.           ; Generate the :ISNEW method
  76.           (send ,name
  77.             :answer :isnew
  78.             '(&rest ,sym &key ,@ivars &allow-other-keys)
  79.  
  80.             ; first :ISNEW setfs 
  81.             ;  for all its declared instance variables
  82.             '(,@(mapcar #'(lambda (arg)
  83.                     `(setf (send self
  84.                             ,(intern (strcat ":" 
  85.                                   (string arg))))
  86.                        ,arg))
  87.                     civars)
  88.  
  89.               ; then the remaining initialization arguments are
  90.               ;  passed to the superclass.
  91.               (apply #'send-super
  92.                  (cons ':isnew
  93.                    (remove-keys
  94.                       ',(mapcar #'(lambda (arg)
  95.                             (intern (strcat ":"
  96.                                    (string arg))))
  97.                             civars)
  98.                       ,sym)))
  99.               self)))))
  100.  
  101.  
  102. ; (defmethod <class> <message> (<arglist>) <body>)
  103.  
  104. (defmacro defmethod (cls message arglist &rest body)
  105.     `(send ,cls
  106.        :answer
  107.        ,message
  108.        ',arglist
  109.        ',body))
  110.  
  111. ; (definst <class> <instname> [<args>...])
  112.  
  113. (defmacro definst (cls name &rest args)
  114.     `(setf ,name
  115.            (send ,cls
  116.              :new
  117.          ,@args)))
  118.  
  119. ; (extensions suggested by Jim Ferrans)
  120.  
  121. (defun classp (name)
  122.        (when (objectp name)
  123.          (eq (send name :class) class)))
  124.  
  125. (defmethod class :superclass () superclass)
  126. (defmethod class :messages () messages)
  127.  
  128. (defmethod object :superclass () nil)
  129.  
  130. (defmethod object :ismemberof (cls)
  131.        (eq (send self :class) cls))
  132.  
  133. (defmethod object :iskindof (cls)
  134.        (do ((this (send self :class) (send this :superclass)))
  135.            ((or (null this)(eq this cls))
  136.         (eq this cls))))
  137.  
  138. (defmethod object :respondsto (selector &aux temp)
  139.        (do ((this (send self :class) (send this :superclass)))
  140.            ((or (null this)
  141.             (setq temp 
  142.               (not (null (assoc selector 
  143.                        (send this :messages))))))
  144.         temp)
  145.            (setf temp nil)))
  146.  
  147.  
  148. (defmethod class :ivars () ivars)
  149.  
  150. (defmethod class :pname () pname)
  151.  
  152. ; :Storeon returns a list that can be executed to re-generate the object.
  153. ; It relies on the object's class being created using DEFCLASS,   so the
  154. ; instance variables can be generated.
  155.  
  156.  
  157. (defmethod object :storeon (&aux cls ivlist res)
  158.        (setq cls
  159.          (send self :class)
  160.          ivlist
  161.          (do ((ivars (send cls :ivars)
  162.                  (append (send super :ivars) ivars))
  163.               (super (send cls :superclass)
  164.                  (send super :superclass)))
  165.              ((eq super object) ivars))
  166.          res
  167.          (mapcan #'(lambda (x) 
  168.                    (let ((temp
  169.                       (intern (strcat ":" (string x)))))
  170.                     (list temp
  171.                           (let ((y (send self temp)))
  172.                            (if (and y 
  173.                                 (or (symbolp y)
  174.                                 (consp y)))
  175.                                (list 'quote y)
  176.                                y)))))
  177.                    ivlist))
  178.        (append (list 'send (make-symbol (send cls :pname)) ':new)
  179.            res))
  180.  
  181. ; For classes we must use a different tact.
  182. ; We will return a PROGN that uses SENDs to create the class and any methods.
  183. ; It also assumes the global environment. None of the DEFxxx functions
  184. ; are needed to do this.
  185.  
  186. ; because of the subrs used in messages, :storeon cannot be  used to
  187. ; generate a reconstructable copy of classes Object and Class.
  188.  
  189. ; Class variables are not set, because there are no class methods in XLISP
  190. ; to do this (one would have to create an instance, and send messages to
  191. ; the instance, and I feel that is going too far).
  192.  
  193.  
  194. (defmethod class :storeon (&aux (classname (intern pname)))
  195.    (nconc (list 'progn)
  196.       (list (list 'setq classname
  197.               (list 'send 'class :new ivars cvars 
  198.                 (if superclass 
  199.                 (intern (send superclass :pname))
  200.                 nil))))
  201.       (list (list 'send classname :set-pname pname))
  202.       (mapcar #'(lambda (mess &aux 
  203.                   (val (if (typep (cdr mess) 'closure)
  204.                        (get-lambda-expression (cdr mess))
  205.                        (list nil nil mess))))
  206.                 (list 'send classname :answer
  207.                   (first mess)
  208.                   (list 'quote (cdadr val))
  209.                   (list 'quote (cddr val))))
  210.           messages)))
  211.  
  212. (setq *features* (cons :classes *features*))
  213.